home *** CD-ROM | disk | FTP | other *** search
/ User's Choice Windows CD / User's Choice Windows CD (CMS Software)(1993).iso / win_a_d / bmpclp.zip / BMPCLIP.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-05  |  15KB  |  468 lines
  1. {$A+,B-,D+,F-,G-,I+,L+,N-,R-,S+,V+,W+,X+}
  2. {$M 8192,8192}
  3. {************************************************}
  4. {                                                }
  5. {   Turbo Pascal for Windows                     }
  6. {   Demo program                                 }
  7. {   Copyright (c) 1991 by Borland International  }
  8. {                                                }
  9. {************************************************}
  10.  
  11. { This is an adaptation of the demo program BSCRLAPP.PAS included
  12.   with Turbo Pascal for Windows.  The changes to this program allow
  13.   a 256 color bitmap to be displayed with the appropriate colors.
  14.   Further modifications were made to the program allowing the user to
  15.   copy the visible area of the bitmap to the Clipboard with the Copy
  16.   command added to the File menu. The code for this is contained in
  17.   the procedure CMCopyBmp. Resource file BMPCLIP.RES is the original
  18.   BSCRLAPP.RES file with the Copy command added to the menu with a
  19.   return value of 205. }
  20.  
  21. {*Modifications to enable the display of 256 color bitmaps by
  22.   Pat Ritchey (CIS:[70007,4660]) are marked with (!!)        }
  23.  
  24. {*Code added to implement copy method by Scott Hanrahan
  25.   (CIS:[70144, 3033]) is marked with (*).                    }
  26.  
  27.  
  28.  
  29. program BMPCLIP;
  30.  
  31. {$R BMPCLIP.RES}
  32.  
  33. uses WinTypes, WinProcs, WinDos, WObjects, StdDlgs, Strings;
  34.  
  35. const
  36.   bsa_Name =  'BitmapScroll';
  37.   cm_Copy = 205; {*}
  38.  
  39. type
  40.  
  41. { TBitScrollApp, a TApplication descendant }
  42.  
  43.   TBitScrollApp = object(TApplication)
  44.     procedure InitMainWindow; virtual;
  45.   end;
  46.  
  47. { TBitScrollWindow, a TWindow descendant }
  48.  
  49.   PScrollWindow = ^TBitScrollWindow;
  50.   TBitScrollWindow = object(TWindow)
  51.     FileName: array[0..fsPathName] of Char;
  52.     BitmapHandle: HBitmap;
  53.     IconizedBits: HBitmap;
  54.     hPal : hPalette;               {!!}
  55.     IconImageValid: Boolean;
  56.     PixelHeight, PixelWidth: Word;
  57.     Mode: Longint;
  58.     constructor Init(ATitle: PChar);
  59.     destructor Done; virtual;
  60.     function GetClassName : PChar; virtual;
  61.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  62.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  63.     procedure CMFileOpen(var Msg: TMessage); virtual cm_First + cm_FileOpen;
  64.     procedure CMCopyBmp(var Msg: TMessage); virtual cm_First + cm_Copy;      {*}
  65.     procedure WMSize(var Msg: TMessage); virtual wm_First + wm_Size;
  66.     procedure AdjustScroller;
  67.     function LoadBitmapFile(Name: PChar): Boolean;
  68.     Procedure CopyDIBPalette(var bmi : TBitMapInfo); {!!}
  69.     function OpenDIB(var TheFile: File): Boolean;
  70.     procedure GetBitmapData(var TheFile: File;
  71.       BitsHandle: THandle; BitsByteSize: Longint);
  72.   end;
  73.  
  74. { __ahIncr, ordinal 114, is a 'magic' function. Defining this
  75.   function causes Windows to patch the value into the passed
  76.   reference.  This makes it a type of global variable. To use
  77.   the value of AHIncr, use Ofs(AHIncr). }
  78.  
  79. procedure AHIncr; far; external 'KERNEL' index 114;
  80.  
  81. { Construct the TBitScrollApp's MainWindow of type TBitScrollWindow }
  82.  
  83. procedure TBitScrollApp.InitMainWindow;
  84. begin
  85.   MainWindow := New(PScrollWindow, Init(bsa_name));
  86. end;
  87.  
  88. { Constructor for a TBitScrollWindow, sets scroll styles and constructs
  89.   the Scroller object.  Also sets the Mode based on whether the display
  90.   is monochrome (two-color) or polychrome. }
  91.  
  92. constructor TBitScrollWindow.Init(ATitle: PChar);
  93. var
  94.   DCHandle: HDC;
  95. begin
  96.   TWindow.Init(nil, ATitle);
  97.   Attr.Style := Attr.Style or ws_VScroll or ws_HScroll;
  98.   Attr.Menu := LoadMenu(HInstance, bsa_Name);
  99.   EnableMenuItem(Attr.Menu, cm_Copy, mf_ByCommand or mf_Grayed); {*}
  100.   BitmapHandle := 0;
  101.   hPal := 0;                {!!}
  102.   IconImageValid := False;
  103.   Scroller := New(PScroller, Init(@Self, 1, 1, 200, 200));
  104.   DCHandle := CreateDC('Display', nil, nil, nil);
  105.   IconizedBits := CreateCompatibleBitmap(DCHandle, 64, 64);
  106.   if GetDeviceCaps(DCHandle, numColors) < 3 then Mode := notSrcCopy
  107.   else Mode := srcCopy;
  108.   DeleteDC(DCHandle);
  109. end;
  110.  
  111. { Change the class name to the application name. }
  112.  
  113. function TBitScrollWindow.GetClassName : PChar;
  114. begin
  115.   GetClassName := bsa_Name;
  116. end;
  117.  
  118. { Allow the iconic picture to be drawn from the client area. }
  119.  
  120. procedure TBitScrollWindow.GetWindowClass(var WndClass: TWndClass);
  121. begin
  122.   TWindow.GetWindowClass(WndClass);
  123.   WndClass.hIcon := 0; { Client area will be painted by the app. }
  124. end;
  125.  
  126. destructor TBitScrollWindow.Done;
  127. begin
  128.   if hPal <> 0 then DeleteObject(hPal);   {!!}
  129.   hPal := 0;                              {!!}
  130.   if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
  131.   TWindow.Done;
  132. end;
  133.  
  134. { If the the 'Open...' menu item is selected, then, using
  135.   the current TFileDlgRec we prompt the user for a new bitmap
  136.   file.  If the user selects one and it is one that we can
  137.   read, we display it in the window and change the window's
  138.   caption to reflect the new bitmap file.  It should be noted
  139.   that we save the old TFileDlgRec just in case we are unable
  140.   to display the bitmap.  This allows us to restore the old
  141.   search criteria. }
  142.  
  143. procedure TBitScrollWindow.CMFileOpen(var Msg: TMessage);
  144. var
  145.   TempName: array[0..fsPathName] of Char;
  146.   CaptionBuffer: array [0..fsPathName+12{bsa_Name} +2{': '} +1{#0}] of Char;
  147. begin
  148.   if Application^.ExecDialog(New(PFileDialog,
  149.     Init(@Self, PChar(sd_FileOpen), StrCopy(TempName, '*.bmp')))) = id_Ok then
  150.     if LoadBitmapFile(TempName) then
  151.     begin
  152.       StrCopy(FileName, TempName);
  153.       StrCopy(CaptionBuffer, bsa_Name);
  154.       StrCat(CaptionBuffer, ': ');
  155.       StrCat(CaptionBuffer, AnsiLower(FileName));
  156.       SetWindowText(HWindow, CaptionBuffer);
  157.       EnableMenuItem(Attr.Menu, cm_Copy, mf_ByCommand or mf_Enabled); {*}
  158.     end;
  159. end;
  160.  
  161. procedure TBitScrollWindow.CMCopyBmp(var Msg: TMessage); {*}
  162. var
  163.   R: TRect;
  164.   DC, MemDC1: HDC;
  165.   OldBitmap1, NewBmp: HBitmap;
  166.   OldCursor: HCursor;
  167.   NWidth, NHeight : LongInt;
  168. begin
  169.   if BitmapHandle <> 0 then
  170.   begin
  171.     DC := GetDC(HWindow);
  172.     MemDC1 := CreateCompatibleDC(DC);
  173.     GetClientRect(HWindow, R);
  174.     NWidth := R.Right;
  175.     NHeight := R.Bottom;
  176.     NewBmp := CreateCompatibleBitmap(DC, NWidth, NHeight);
  177.     OldBitmap1 := SelectObject(MemDC1, NewBmp);
  178.     if NewBmp = 0 then
  179.     begin
  180.       MessageBox(HWindow, 'Unable to copy Bitmap', 'Error',
  181.         mb_IconExclamation or mb_ok);
  182.       SelectObject(MemDC1, OldBitmap1);
  183.       DeleteDC(MemDC1);
  184.       ReleaseDC(HWindow,DC)
  185.     end
  186.     else begin
  187.       OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  188.       BitBlt(MemDC1, 0, 0, NWidth, NHeight, DC, 0, 0,
  189.         Mode);
  190.       OpenClipboard(HWindow);
  191.       EmptyClipboard;
  192.       SetClipboardData(cf_Bitmap, NewBmp);
  193.       CloseClipboard;
  194.       SetCursor(OldCursor);
  195.       SelectObject(MemDC1, OldBitmap1);
  196.       DeleteDC(MemDC1);
  197.       ReleaseDC(HWindow,DC)
  198.     end
  199.   end;
  200. end;
  201.  
  202.  
  203. { Adjust the Scroller range so that the the origin is the
  204.   upper-most scrollable point and the corner is the
  205.   bottom-most. }
  206.  
  207. procedure TBitScrollWindow.AdjustScroller;
  208. var
  209.   ClientRect: TRect;
  210. begin
  211.   GetClientRect(HWindow, ClientRect);
  212.   with ClientRect do
  213.     Scroller^.SetRange(PixelWidth - (right - left),
  214.       PixelHeight - (bottom - top));
  215.   Scroller^.ScrollTo(0, 0);
  216.   InvalidateRect(HWindow, nil, True);
  217. end;
  218.  
  219. { Reset scroller range. }
  220.  
  221. procedure TBitScrollWindow.WMSize(var Msg: TMessage);
  222. var
  223.   ClientRect: TRect;
  224.   DC, MemDC1, MemDC2: HDC;
  225.   OldBitmap1, OldBitmap2: HBitmap;
  226.   OldCursor: HCursor;
  227. begin
  228.   TWindow.WMSize(Msg);
  229.   Scroller^.AutoOrg := not (Msg.wParam = sizeIconic);
  230.   if not (Msg.WParam = sizeIconic) then AdjustScroller
  231.   else if not IconImageValid and (BitmapHandle <> 0) then
  232.   begin
  233.     DC := GetDC(HWindow);
  234.     MemDC1 := CreateCompatibleDC(DC);
  235.     MemDC2 := CreateCompatibleDC(DC);
  236.     ReleaseDC(HWindow, DC);
  237.     OldBitmap1 := SelectObject(MemDC1, IconizedBits);
  238.     OldBitmap2 := SelectObject(MemDC2, BitmapHandle);
  239.     OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  240.     StretchBlt(MemDC1, 0, 0, Msg.lParamLo, Msg.lParamHi, MemDC2,
  241.       0, 0, PixelWidth, PixelHeight, SrcCopy);
  242.     SetCursor(OldCursor);
  243.     SelectObject(MemDC1, OldBitmap1);
  244.     SelectObject(MemDC2, OldBitmap2);
  245.     DeleteDC(MemDC1);
  246.     DeleteDC(MemDC2);
  247.     IconImageValid := True;
  248.   end;
  249. end;
  250.  
  251. { Copys the bitmap bit data from the file into memory. Since
  252.   copying cannot cross a segment (64K) boundary, we are forced
  253.   to do segment arithmetic to compute the next segment.  Created
  254.   a LongType type to simplify the process. }
  255.  
  256. procedure TBitScrollWindow.GetBitmapData(var TheFile: File;
  257.   BitsHandle: THandle; BitsByteSize: Longint);
  258. type
  259.   LongType = record
  260.     case Word of
  261.       0: (Ptr: Pointer);
  262.       1: (Long: Longint);
  263.       2: (Lo: Word;
  264.       Hi: Word);
  265.   end;
  266. var
  267.   Count: Longint;
  268.   Start, ToAddr, Bits: LongType;
  269. begin
  270.   Start.Long := 0;
  271.   Bits.Ptr := GlobalLock(BitsHandle);
  272.   Count := BitsByteSize - Start.Long;
  273.   while Count > 0 do
  274.   begin
  275.     ToAddr.Hi := Bits.Hi + (Start.Hi * Ofs(AHIncr));
  276.     ToAddr.Lo := Start.Lo;
  277.     if Count > $4000 then Count := $4000;
  278.     BlockRead(TheFile, ToAddr.Ptr^, Count);
  279.     Start.Long := Start.Long + Count;
  280.     Count := BitsByteSize - Start.Long;
  281.   end;
  282.   GlobalUnlock(BitsHandle);
  283. end;
  284.  
  285. Procedure TBitScrollWindow.CopyDIBPalette(var bmi : TBitMapInfo);  {!!}
  286. var
  287.   LogPal : PLogPalette;
  288.   i : integer;
  289.   PalSize : integer;
  290.   sz : word;
  291. begin
  292.   if hPal <> 0 then {get rid of palette from previous bitmap }
  293.      begin
  294.      DeleteObject(hPal);
  295.      hPal := 0;
  296.      end;
  297.   PalSize := 1 shl bmi.bmiHeader.biBitCount;
  298.   sz := Sizeof(TLogPalette)+Pred(PalSize)*Sizeof(TPaletteEntry);
  299.   GetMem(LogPal,sz);
  300.   for i := 0 to Pred(PalSize) do
  301.      With LogPal^ do
  302.        begin
  303.        palNumEntries := PalSize;
  304.        palVersion := $0300;
  305.        With palPalEntry[i],bmi.bmicolors[i] do
  306.         begin
  307.         peRed := rgbRed;
  308.         peBlue := rgbBlue;
  309.         peGreen := rgbGreen;
  310.         peFlags := 0;
  311.         end;
  312.        end;
  313.   hPal := CreatePalette(LogPal^);
  314.   FreeMem(LogPal,sz);
  315. end;
  316.  
  317. { Attempt to open a Windows 3.0 device independent bitmap }
  318.  
  319. function TBitScrollWindow.OpenDIB(var TheFile: File): Boolean;
  320. var
  321.   bitCount: Word;
  322.   size: Word;
  323.   longWidth: Longint;
  324.   DCHandle: HDC;
  325.   BitsPtr: Pointer;
  326.   BitmapInfo: PBitmapInfo;
  327.   BitsHandle, NewBitmapHandle,OldPal: THandle;      {!!}
  328.   NewPixelWidth, NewPixelHeight: Word;
  329. begin
  330.   OpenDIB := True;
  331.   Seek(TheFile, 28);
  332.   BlockRead(TheFile, bitCount, SizeOf(bitCount));
  333.   if bitCount <= 8 then
  334.   begin
  335.     size := SizeOf(TBitmapInfoHeader) + ((1 shl bitCount) * SizeOf(TRGBQuad));
  336.     BitmapInfo := MemAlloc(size);
  337.     Seek(TheFile, SizeOf(TBitmapFileHeader));
  338.     BlockRead(TheFile, BitmapInfo^, size);
  339.     NewPixelWidth := BitmapInfo^.bmiHeader.biWidth;
  340.     NewPixelHeight := BitmapInfo^.bmiHeader.biHeight;
  341.     CopyDIBPalette(BitMapInfo^);
  342.     longWidth := (((NewPixelWidth * bitCount) + 31) div 32) * 4;
  343.     BitmapInfo^.bmiHeader.biSizeImage := longWidth * NewPixelHeight;
  344.     GlobalCompact(-1);
  345.     BitsHandle := GlobalAlloc(gmem_Moveable or gmem_Zeroinit,
  346.       BitmapInfo^.bmiHeader.biSizeImage);
  347.     GetBitmapData(TheFile, BitsHandle, BitmapInfo^.bmiHeader.biSizeImage);
  348.     DCHandle := CreateDC('Display', nil, nil, nil);
  349.     BitsPtr := GlobalLock(BitsHandle);
  350.     OldPal := SelectPalette(DCHandle,hPal,false); {!!}
  351.     UnrealizeObject(hPal);                        {!!}
  352.     RealizePalette(DCHandle);                     {!!}
  353.     NewBitmapHandle :=
  354.       CreateDIBitmap(DCHandle, BitmapInfo^.bmiHeader, cbm_Init, BitsPtr,
  355.       BitmapInfo^, 0);
  356.     SelectPalette(DCHandle,OldPal,false);         {!!}
  357.     DeleteDC(DCHandle);
  358.     GlobalUnlock(BitsHandle);
  359.     GlobalFree(BitsHandle);
  360.     FreeMem(BitmapInfo, size);
  361.     if NewBitmapHandle <> 0 then
  362.     begin
  363.       if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
  364.       BitmapHandle := NewBitmapHandle;
  365.       PixelWidth := NewPixelWidth;
  366.       PixelHeight := NewPixelHeight;
  367.     end
  368.     else
  369.       OpenDIB := False;
  370.   end
  371.   else
  372.     OpenDIB := False;
  373. end;
  374.  
  375. { Test if the passed file is a Windows 3.0 DI bitmap and if so read it.
  376.   Report errors if unable to do so. Adjust the Scroller to the new
  377.   bitmap dimensions. }
  378.  
  379. function TBitScrollWindow.LoadBitmapFile(Name: PChar): Boolean;
  380. var
  381.   TheFile: File;
  382.   TestWin30Bitmap: Longint;
  383.   ErrorMsg: PChar;
  384.   OldCursor: HCursor;
  385. begin
  386.   ErrorMsg := nil;
  387.   OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  388.   Assign(TheFile, Name);
  389.   {$I-}
  390.   Reset(TheFile, 1);
  391.   {$I+}
  392.   if IOResult = 0 then
  393.   begin
  394.     Seek(TheFile, 14);
  395.     BlockRead(TheFile, TestWin30Bitmap, SizeOf(TestWin30Bitmap));
  396.     if TestWin30Bitmap = 40 then
  397.       if OpenDIB(TheFile) then
  398.       begin
  399.     AdjustScroller;
  400.     IconImageValid := False;
  401.       end
  402.       else ErrorMsg := 'Unable to create Windows 3.0 bitmap from file'
  403.     else
  404.       ErrorMsg := 'Not a Windows 3.0 bitmap file';
  405.     Close(TheFile);
  406.   end
  407.   else
  408.     ErrorMsg := 'Cannot open bitmap file';
  409.   SetCursor(OldCursor);
  410.   if ErrorMsg = nil then LoadBitmapFile := True else
  411.   begin
  412.     MessageBox(HWindow, ErrorMsg, bsa_Name, mb_Ok);
  413.     LoadBitmapFile := False;
  414.   end;
  415. end;
  416.  
  417. { Responds to an incoming "paint" message by redrawing the bitmap.  (The
  418.   Scroller's BeginView method, which sets the viewport origin relative
  419.   to the present scroll position, has already been called. )  }
  420.  
  421.  
  422. procedure TBitScrollWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  423. var
  424.   MemoryDC: HDC;
  425.   OldBitmapHandle: THandle;
  426.   OldPal : THandle;       {!!}
  427.   ClientRect: TRect;
  428. begin
  429.   if BitmapHandle <> 0 then
  430.   begin
  431.  
  432.     MemoryDC := CreateCompatibleDC(PaintDC);
  433.     OldPal := SelectPalette(MemoryDC,hPal,false);  {!!}
  434.     UnrealizeObject(hPal);                         {!!}
  435.     RealizePalette(MemoryDC);                      {!!}
  436.     if IsIconic(HWindow) then
  437.       OldBitmapHandle := SelectObject(MemoryDC, IconizedBits)
  438.     else
  439.     begin
  440.       OldBitmapHandle := SelectObject(MemoryDC, BitmapHandle);
  441.       if Mode = srcCopy then
  442.       begin
  443.     SetBkColor(PaintDC, GetNearestColor(PaintDC, $800000));
  444.     SetTextColor(PaintDC, $FFFFFF);
  445.       end;
  446.     end;
  447.  
  448.     BitBlt(PaintDC, 0, 0, PixelWidth, PixelHeight, MemoryDC, 0, 0,
  449.       Mode);
  450.     SelectObject(MemoryDC,OLDPal);    {!!}
  451.     SelectObject(MemoryDC, OldBitmapHandle);
  452.     DeleteDC(MemoryDC);
  453.   end;
  454. end;
  455.  
  456. { Declare a variable of type TBitScrollApp }
  457.  
  458. var
  459.   ScrollApp: TBitScrollApp;
  460.  
  461. { Run the BitScrollApp }
  462.  
  463. begin
  464.   ScrollApp.Init(bsa_Name);
  465.   ScrollApp.Run;
  466.   ScrollApp.Done;
  467. end.
  468.